Giga Games 1

home *** CD-ROM | disk | FTP | other *** search

/ Giga Games 1 / Giga Games.iso / net / vir_real / veos / part07 < prev next >

Wrap

Text File | 1993-06-20 | 85.8 KB | 3,338 lines

Path: wupost!uunet!decwrl!vixie!vixie!not-for-mail From: voodoo@hitl.washington.edu (Geoffery Coco) Newsgroups: comp.sources.unix Subject: v26i190: veos-2.0 - The Virtual Environment Operating Shell, V2.0, Part07/16 Date: 25 Apr 1993 23:15:09 -0700 Organization: Vixie Home Computing Lines: 3325 Sender: vixie@vix.com Approved: paul@vix.com Message-ID: <1rfuld$5nm@efficacy.home.vix.com> NNTP-Posting-Host: efficacy.home.vix.com Submitted-By: voodoo@hitl.washington.edu (Geoffery Coco) Posting-Number: Volume 26, Issue 190 Archive-Name: veos-2.0/part07 #! /bin/sh # This is a shell archive. Remove anything before this line, then unpack # it by saving it into a file and typing "sh file". To overwrite existing # files, type "sh file -c". You can also feed this as standard input via # unshar, or by typing "sh <file", e.g.. If this archive is complete, you # will see the following message at the end: # "End of archive 7 (of 16)." # Contents: kernel_private/src/fern/fe_int.lsp # kernel_private/src/talk/socket.c # src/kernel_current/fern/fe_int.lsp src/xlisp/xcore/c/xlobj.c # src/xlisp/xcore/c/xlstr.c # Wrapped by vixie@efficacy.home.vix.com on Sun Apr 25 23:10:38 1993 PATH=/bin:/usr/bin:/usr/ucb ; export PATH if test -f 'kernel_private/src/fern/fe_int.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/fern/fe_int.lsp'\" else echo shar: Extracting \"'kernel_private/src/fern/fe_int.lsp'\" $16110 characters$ sed "s/^X//" >'kernel_private/src/fern/fe_int.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_int.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;=========================================================== X;; Internal X;;=========================================================== X X(defun fe-put.int (int) X (vput int '((~ "perc" X @ X @ X > @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int (&key (test-time nil)) X (car (vcopy '(("perc" X @ X @ X > @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int () X (vget '(("perc" X @ X @ X (> @@) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int () X (car (vput "%" '((~ "perc" X @ X @ X > @) **)))) X X;;----------------------------------------------------------- X X X X X;;----------------------------------------------------------- X;; The following functions which manipulate the locl X;; sub-partition were composed by Andy MacDonald X;;----------------------------------------------------------- X X X;;=========================================================== X;; Local X;;=========================================================== X X(defun fe-put.int.locl (locl) X (vput locl '((~ "perc" X @2 X (> @ @2)) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int.locl (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (> @ @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.locl () X (vget '(("perc" X @2 X ((> @@) @2)) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl () X (car (vput '((~ "perc" X @2 X (> @ @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Objects X;;=========================================================== X X(defun fe-jam.int.locl.ob (ob) X (vput ob '((~ "perc" X @2 X ((^ @@) @2)) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.int.locl.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @2 X ((> (,(car ob) @) **) @2)) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.int.locl.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.int.locl.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X ((> (,ob-name @) **) @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass object name, returns entire object X(defun fe-xtrct.int.locl.ob (ob-name) X (car (vget `(("perc" X @2 X ((> (,ob-name @) **) @2)) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl.ob (ob-name) X (car (vput "%" `((~ "perc" X @2 X (((~ ,ob-name > @) **) @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Object - Complex X;;=========================================================== X X(defun fe-copy.int.locl.ob.names () X (vcopy `(("perc" X @2 X (((> @ @) **) @2)) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Local Object Attributes X;;=========================================================== X X(defun fe-jam.int.locl.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @2 X (((~ ,ob-name (^ @@)) **) @2)) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.int.locl.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.int.locl.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @2 X (((~ ,ob-name (> (,(car attr) @) **)) **) @2)) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.int.locl.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.locl.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @2 X (((,ob-name (> (,attr-name @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @2 X (((~ ,ob-name ((~ ,attr-name > @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.int.locl.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (((,ob-name (> (,attr-name @) **)) **) @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.int.locl.ob.attr.names (ob-name) X (vcopy `(("perc" X @2 X (((,ob-name ((> @ @) **)) **) @2)) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.int.locl.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @2 X (((,ob-name ((,attr-name > @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sublings X;;=========================================================== X X(defun fe-put.int.subs (subs) X (vput subs '((~ "perc" X @2 X (@ > @ @)) **))) X X;;----------------------------------------------------------- X X;; cache this frequently used pattern in C level fern. X;; later, calls to fe-copy.int.subs use precomputed pattern. X X(fbase-init-copy.int.subs '(("perc" X @2 X (@ > @ @)) **)) X X#| X(defun fe-copy.int.subs (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (@ > @ @)) **) X :test-time test-time))) X|# X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs () X (vget '(("perc" X @2 X (@ (> @@) @)) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs () X (car (vput "%" '((~ "perc" X @2 X (@ > @ @)) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Sublings Entities X;;=========================================================== X X(defun fe-jam.int.subs.ent (ent) X (vput ent '((~ "perc" X @2 X (@ (^ @@) @)) **))) X X;;----------------------------------------------------------- X X;; an ent is: (uid (ob-list)) X(defun fe-put.int.subs.ent (ent) X (cond X X ;; assume the ent exists, swap in the new ent X ((car (vput ent `((~ "perc" X @2 X (@ (> (,(car ent) @) **) @) X ) **)))) X X ;; ent didn't exist, insert new ent X ((fe-jam.int.subs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.subs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ (> (,uid @) **) @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs.ent (uid) X (car (vget `(("perc" X @2 X (@ (> (,uid @) **) @) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs.ent (uid) X (car (vput "%" `((~ "perc" X @2 X (@ ((~ ,uid > @) **) @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sublings Entities - Complex X;;=========================================================== X X(defun fe-copy.int.subs.uids () X (vcopy '(("perc" X @2 X (@ ((> @ @) **) @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Sublings Entities Objects X;;=========================================================== X X X(defun fe-jam.int.subs.ent.ob (uid ob) X (cond X X ;; assume entity exists, insert new object X ((vput ob `((~ "perc" X @2 X (@ ((~ ,uid (^ @@)) **) @) X ) **))) X X ;; entity wasn't there, insert new entity with new object X ((fe-jam.int.subs.ent `(,uid (,ob)))) X )) X X;;----------------------------------------------------------- X X;; ob is a normal object structure: (name (attr-list)) X(defun fe-put.int.subs.ent.ob (uid ob) X (cond X X ;; assume entity and object exist, swap in new object X ((car (vput ob `((~ "perc" X @2 X (@ ((~ ,uid (> (,(car ob) @) **)) **) @) X ) **)))) X X ;; object wasn't there, assume entity exists, insert new object X ((fe-jam.int.subs.ent.ob uid ob)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.subs.ent.ob (uid ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ ((,uid (> (,ob-name @) **)) **) @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs.ent.ob (uid ob-name) X (car (vget `(("perc" X @2 X (@ ((,uid (> (,ob-name @) **)) **) @) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs.ent.ob (uid ob-name) X (car (vput "%" `((~ "perc" X @2 X (@ ((~ ,uid ((~ ,ob-name > @) **)) **) @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Subling Entities Objects - Complex X;;=========================================================== X X;; pass uid, get list of it's ob names X(defun fe-copy.int.subs.ent.ob.names (uid) X (vcopy `(("perc" X @2 X (@ ((,uid ((> @ @) **)) **) @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Subling Entities Objects Attributes X;;=========================================================== X X X(defun fe-jam.int.subs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume entity and ob exists, insert new attr X ((vput attr `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-name (^ @@)) **)) **) X @) X ) **))) X X ;; ob wasn't there, insert new ob with new attr X ((fe-jam.int.subs.ent.ob uid `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X;; attr is ("attr-name" attr-val) X(defun fe-put.int.subs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume the ent, ob and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-name (> (,(car attr) @) **)) **)) **) X @) X ) **)))) X X ;; attr wasn't there, insert new attr X ((fe-jam.int.subs.ent.ob.attr uid ob-name attr)) X )) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.int.subs.ent.ob.attr (uid ob-num attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-xtrct.int.subs.ent.ob.attr (uid ob-num attr-name) X (car (vget `(("perc" X @2 X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-get.int.subs.ent.ob.attr (uid ob-num attr-name) X (car (vput "%" `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-num ((~ ,attr-name > @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Subling Entities Objects Attributes - Complex X;;=========================================================== X X;; pass uid and ob, return attr-list X(defun fe-copy.int.subs.ent.ob.attr.names (uid ob-name) X (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-name ((> @ @) **)) **)) **) X @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass attr, return values of all objects of all sibs X(defun fe-copy.int.subs.attr.vals (attr-name) X (vcopy `(("perc" X @2 X (@ X ((@ ((@ ((,attr-name > @) **)) **)) **) X @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.int.subs.ent.ob.attr.val (uid ob-num attr-name) X (car (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-num ((,attr-name > @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X X X X X;;=========================================================== X;; Filters X;;=========================================================== X X(defun fe-put.int.fltrs (fltr) X (vput fltr '((~ "perc" X @2 X (@2 > @)) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int.fltrs (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (@2 > @)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.fltrs () X (vget '(("perc" X @2 X (@2 (> @@))) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.fltrs () X (car (vput "%" '((~ "perc" X @2 X (@2 > @)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Fltrs Entities X;;=========================================================== X X(defun fe-jam.int.fltrs.ent (ent) X (vput ent '((~ "perc" X @2 X (@2 (^ @@))) **))) X X;;----------------------------------------------------------- X X;; an ent is: (uid (ob-list)) X(defun fe-put.int.fltrs.ent (ent) X (cond X X ;; assume the ent exists, swap in the new ent X ((car (vput ent `((~ "perc" X @2 X (@2 (> (,(car ent) @) **)) X ) **)))) X X ;; ent didn't exist, insert new ent X ((fe-jam.int.fltrs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.fltrs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@2 (> (,uid @) **)) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.fltrs.ent (uid) X (car (vget `(("perc" X @2 X (@2 (> (,uid @) **)) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.fltrs.ent (uid) X (car (vput "%" `((~ "perc" X @2 X (@2 ((~ ,uid > @) **)) X ) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Internal Entity Filter Processing X;;=========================================================== X X X;;----------------------------------------------------------- X X(defun fe-fltr.int.subs (uid &key (test-time nil)) X (delete uid X (fe-copy.int.subs :test-time test-time) X :test (lambda (x y) (equal x (car y))))) X X;;----------------------------------------------------------- X X(defun fe-fltr.int.subs.uids (uid) X (delete uid X (fe-copy.int.subs.uids) X :test 'equal)) X X;;----------------------------------------------------------- X X X X END_OF_FILE if test 16110 -ne `wc -c <'kernel_private/src/fern/fe_int.lsp'`; then echo shar: \"'kernel_private/src/fern/fe_int.lsp'\" unpacked with wrong size! fi # end of 'kernel_private/src/fern/fe_int.lsp' fi if test -f 'kernel_private/src/talk/socket.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'kernel_private/src/talk/socket.c'\" else echo shar: Extracting \"'kernel_private/src/talk/socket.c'\" $16709 characters$ sed "s/^X//" >'kernel_private/src/talk/socket.c' <<'END_OF_FILE' X/**************************************************************************************** X * * X * file: socket.c * X * * X * November 14, 1990: The network and transport layer for inter-entity message passing * X * library, 'talk' for the VEOS project. * X * * X * by Geoffrey P. Coco at the HITLab, Seattle. * X * these functions are based on BSD socket code by Dan Pezely. * X * * X ****************************************************************************************/ X X/**************************************************************************************** X * Copyright (C) 1992 Geoffrey P. Coco, Human Interface Technology Lab, Seattle * X ****************************************************************************************/ X X X X/**************************************************************************************** X * include the papa include file */ X X#include "kernel.h" X X#include <sys/types.h> X#include <sys/socket.h> X#include <netinet/in.h> X#include <netinet/tcp.h> X#include <netdb.h> /* for get_*_byname() */ X#include <stropts.h> /* ioctl() streamio */ X#include <fcntl.h> X#include "signal.h" X X/****************************************************************************************/ X X X X/**************************************************************************************** X * forward function declarations */ X XTVeosErr Sock_Connect(); XTVeosErr Sock_Listen(); XTVeosErr Sock_ReadSelect(); XTVeosErr Sock_WriteSelect(); XTVeosErr Sock_Accept(); XTVeosErr Sock_Transmit(); XTVeosErr Sock_Receive(); XTVeosErr Sock_Close(); X X/****************************************************************************************/ X X X X/**************************************************************************************** X * local function declarations */ X XTVeosErr Sock_MixItUp(); XTVeosErr Sock_ResolveHost(); Xu_long Sock_ConvertAddr(); X X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_Connect(iSocketFD, pUid, sProtocolName) X int *iSocketFD; X TPUid pUid; X char *sProtocolName; X{ X struct sockaddr_in socketName; X TVeosErr iErr; X int iProto, iOption, iBufSize; X X X /** translate given network params into useable form **/ X X iErr = Sock_MixItUp(&pUid->iPort, sProtocolName, &iProto); X if (iErr == VEOS_SUCCESS) { X X X /** copy the address of the receiving host **/ X X socketName.sin_addr.s_addr = pUid->lHost; X X X /** create socket with specified protocol **/ X X socketName.sin_family = AF_INET; X socketName.sin_port = htons(pUid->iPort); X X *iSocketFD = socket(socketName.sin_family, SOCK_STREAM, iProto); X X if (*iSocketFD == TALK_BOGUS_FD) X iErr = TALK_CREATE; X X else { X X X /** attempt to connect to given address **/ X X if (connect(*iSocketFD, &socketName, sizeof(socketName)) < 0) X X iErr = TALK_CONNECT; X X X else { X/* X iBufSize = 16384; X if (setsockopt(*iSocketFD, SOL_SOCKET, SO_SNDBUF, X (char *) &iBufSize, sizeof(int)) < 0) X iErr = TALK_FLAGS; X*/ X iOption = TRUE; X if (setsockopt(*iSocketFD, IPPROTO_TCP, TCP_NODELAY, X &iOption, sizeof(int)) == -1) X iErr = TALK_FLAGS; X X /** set non-blocking write bit **/ X X fcntl(*iSocketFD, F_SETFL, FNDELAY); X X FD_SET(*iSocketFD, &OPEN_WRITE_SOCKETS); X } X X if (iErr != VEOS_SUCCESS) X Sock_Close(iSocketFD); X } X } X X return(iErr); X X } /* Sock_Connect */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_Listen(iSocketFD, iPortNumber, sProtocolName, iAttitude) X int *iSocketFD; X int iPortNumber; X char *sProtocolName; X int iAttitude; X{ X struct sockaddr_in socketName; X TVeosErr iErr; X int iProto, iOption; X int iZoot; X X iErr = Sock_MixItUp(&iPortNumber, sProtocolName, &iProto); X if (iErr == VEOS_SUCCESS) { X X X X /** create socket with specified protocol **/ X X socketName.sin_family = AF_INET; /* specify socket to be of INTERNET family */ X X *iSocketFD = socket(socketName.sin_family, SOCK_STREAM, iProto); X X if (*iSocketFD == TALK_BOGUS_FD) X iErr = TALK_CREATE; X X else { X socketName.sin_addr.s_addr = htonl(INADDR_ANY); X socketName.sin_port = htons(iPortNumber); X X if (iAttitude == TALK_AGRESSIVE) { X iOption = TRUE; X if (setsockopt(*iSocketFD, SOL_SOCKET, SO_REUSEADDR, X &iOption, sizeof(int)) == -1) X iErr = TALK_FLAGS; X } X X if (iErr == VEOS_SUCCESS) { X X /** register this socket with system for us **/ X X if (bind(*iSocketFD, &socketName, sizeof(socketName)) < 0) { X X iErr = TALK_BIND; X } X X else { X /** listen on the socket **/ X X if (listen(*iSocketFD, TALK_QUEUE_SIZE ) < 0) X iErr = TALK_LISTEN; X X else { X /** have this socket generate an interrupt X ** when another entity connects. X **/ X/* X fcntl(*iSocketFD, F_SETOWN, getpid()); X fcntl(*iSocketFD, F_SETFL, FASYNC); X*/ X FD_SET(*iSocketFD, &OPEN_READ_SOCKETS); X } X } X } X } X if (iErr != VEOS_SUCCESS) { X X Sock_Close(iSocketFD); X *iSocketFD = TALK_BOGUS_FD; X } X } X X return(iErr); X X } /* Sock_Listen */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_ReadSelect(iSocketFD) X int iSocketFD; X{ X struct timeval timeVal; X fd_set tempFDSet; X int iSize; X TVeosErr iErr; X X X iErr = VEOS_SUCCESS; X X X /** create a local copy of the fd_set since it gets modified by select() **/ X X bcopy((char*) &OPEN_READ_SOCKETS, (char*) &tempFDSet, sizeof(fd_set)); X X X X /** some implementations of select() might modify timeVal, so we ** X ** must keep resetting it rather then making it global or static. **/ X X timeVal.tv_sec = 0; X timeVal.tv_usec = 0; X X iSize = select(FD_SETSIZE, &tempFDSet, nil, nil, &timeVal); X X if (iSize < 0) X iErr = TALK_SELECT; X X else if (iSize == 0) X iErr = TALK_SELECT_TIMEOUT; X X else if (!FD_ISSET(iSocketFD, &tempFDSet)) X iErr = TALK_NOCONN; X X X return(iErr); X X } /* Sock_ReadSelect */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Sock_ReadSelect */ X XTVeosErr Sock_WriteSelect(iSocketFD) X int iSocketFD; X{ X struct timeval timeVal; X fd_set tempFDSet; X int iSize; X TVeosErr iErr; X X X iErr = VEOS_SUCCESS; X X X /** create a local copy of the fd_set since it gets modified by select() **/ X X bcopy((char*) &OPEN_WRITE_SOCKETS, (char*) &tempFDSet, sizeof(fd_set)); X X X X /** some implementations of select() might modify timeVal, so we ** X ** must keep resetting it rather then making it global or static. **/ X X timeVal.tv_sec = 0; X timeVal.tv_usec = 0; X X iSize = select(FD_SETSIZE, nil, &tempFDSet, nil, &timeVal); X X if (TRAP_FLAGS & 0x00000001 << SIGPIPE) { X TRAP_FLAGS = TRAP_FLAGS & ~(0x00000001 << SIGPIPE); X TERMINATE = FALSE; X iErr = TALK_CONN_CLOSED; X } X X else if (iSize < 0) X iErr = TALK_SELECT; X X else if (iSize == 0) X iErr = TALK_SELECT_TIMEOUT; X X else if (!FD_ISSET(iSocketFD, &tempFDSet)) X iErr = TALK_NOCONN; X X X return(iErr); X X } /* Sock_WriteSelect */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Sock_Accept */ X XTVeosErr Sock_Accept(iSocketFD, iSocketIOFD) X int iSocketFD; X int *iSocketIOFD; X{ X TVeosErr iErr; X int iBufSize; X X iErr = TALK_ACCEPT; X X *iSocketIOFD = accept(iSocketFD, nil, nil); X if (*iSocketIOFD >= 0) { X X /** setup socket for large buffers and non-blocking reading **/ X/* X iBufSize = 16384; X if (setsockopt(*iSocketIOFD, SOL_SOCKET, SO_RCVBUF, X (char *) &iBufSize, sizeof(int)) < 0 || X*/ X /** convert msgsock to streams message-nondiscard-mode **/ X X if (fcntl(*iSocketIOFD, F_SETFL, FNDELAY) == -1) X Sock_Close(iSocketIOFD); X X else { X FD_SET(*iSocketIOFD, &OPEN_READ_SOCKETS); X iErr = VEOS_SUCCESS; X } X } X X return(iErr); X X} /* Sock_Accept */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Sock_Transmit */ X XTVeosErr Sock_Transmit(iSocketFD, sMessage, pLen) X int iSocketFD; X char *sMessage; X int *pLen; X{ X int iNetAction; X TVeosErr iErr; X boolean bTrap; X X iErr = VEOS_FAILURE; X X X /** send the string to the given socket destination **/ X X iNetAction = write(iSocketFD, sMessage, *pLen); X X CATCH_TRAP(SIGPIPE, bTrap); X if (bTrap) X iErr = TALK_CONN_CLOSED; X X X else if (iNetAction < 0) { X X /** expected result when can't write **/ X X if (errno == EAGAIN || errno == EWOULDBLOCK) X iErr = TALK_SPEAK_BLOCKED; X X else X perror("shell: write"); X } X X else if (iNetAction > 0) { X X *pLen = iNetAction; X iErr = VEOS_SUCCESS; X } X X return(iErr); X X } /* Sock_Transmit */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * Sock_Receive */ X XTVeosErr Sock_Receive(iSocketFD, sBuffer, iBufferSize) X int iSocketFD; X char *sBuffer; X int *iBufferSize; X{ X TVeosErr iErr; X int iNetAction; X X X iErr = VEOS_FAILURE; /* pessimism */ X X X /** look for unread data in socket **/ X X iNetAction = read(iSocketFD, sBuffer, *iBufferSize); X X X X /** connection still open, but no data **/ X X if (iNetAction < 0) { X X /** expected result when no data **/ X X if (errno == EAGAIN || errno == EWOULDBLOCK) X iErr = TALK_LISTEN_BLOCKED; X X else X perror("shell: read"); X } X X X /** there was some data in the socket **/ X X else if (iNetAction > 0) { X X iErr = VEOS_SUCCESS; X *iBufferSize = iNetAction; X } X X X /** conneciton closed from other end **/ X X else X iErr = TALK_CONN_CLOSED; X X X return(iErr); X X } /* Sock_Receive */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X ** Inet Socket Close X ** X ** usage: status = Sock_Close( &socketFD ); X ** params: pointer to file descriptor of socket X ** returns: VEOS_SUCCESS or TALK_CLOSE X **/ X XTVeosErr Sock_Close(iSocketFD) X int *iSocketFD; X{ X TVeosErr iErr; X X iErr = VEOS_SUCCESS; X X X if (*iSocketFD != TALK_BOGUS_FD) { X X FD_CLR(*iSocketFD, &OPEN_WRITE_SOCKETS); X FD_CLR(*iSocketFD, &OPEN_READ_SOCKETS); X X shutdown(*iSocketFD, 2); X X if (close(*iSocketFD) == -1) X iErr = TALK_CLOSE; X X else X *iSocketFD = TALK_BOGUS_FD; X } X X return(iErr); X X} /* Sock_Close */ X/****************************************************************************************/ X X X X X/**************************************************************************************** X * local routines * X ****************************************************************************************/ X X X X/**************************************************************************************** X * Sock_MixItUp */ X XTVeosErr Sock_MixItUp(iPortNumber, sProtocolName, iProto) X char *sProtocolName; X int *iPortNumber, *iProto; X{ X struct protoent *protocolInfo, *getprotobyname(); X TVeosErr iErr; X X iErr = VEOS_FAILURE; X X if (*iPortNumber > 0) { X X protocolInfo = getprotobyname(sProtocolName); X if (protocolInfo == nil) X iErr = TALK_PROTOCOL; X X else { X *iProto = protocolInfo->p_proto; X iErr = VEOS_SUCCESS; X } X } X X return(iErr); X X } /* Sock_MixItUp */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_ResolveHost(sHostName, pIpAddr) X char *sHostName; X u_long *pIpAddr; X{ X TVeosErr iErr; X X X /** host address may already be in internet form **/ X X if (isdigit(sHostName[0])) X iErr = Sock_StrAddr2IP(sHostName, pIpAddr); X X else X iErr = Sock_StrHost2IP(sHostName, pIpAddr); X X X return(iErr); X X} /* Sock_ResolveHost */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Sock_StrHost2IP(sHostName, pIpAddr) X char *sHostName; X u_long *pIpAddr; X{ X TVeosErr iErr; X struct hostent *hostInfo, *gethostbyname(); X TPHostNode pFinger; X X iErr = VEOS_FAILURE; X X if (sHostName) { X X /** try to find this host in hash table first **/ X X for (pFinger = SOCK_HOSTS[sHostName[0] - 'a']; X pFinger; X pFinger = pFinger->pNext) { X X if (strcmp(pFinger->sHostName, sHostName) == 0) { X iErr = VEOS_SUCCESS; X break; X } X } X X X if (!pFinger) { X X /** find host by calling unix kernel **/ X X iErr = TALK_HOST; X if (hostInfo = gethostbyname(sHostName)) { X X iErr = Shell_NewBlock(sizeof(THostNode), &pFinger, "host-node"); X if (iErr == VEOS_SUCCESS) { X X pFinger->sHostName = strdup(sHostName); X pFinger->lHost = *(u_long *) hostInfo->h_addr_list[0]; X X X /** insert new host into hash table **/ X X pFinger->pNext = SOCK_HOSTS[sHostName[0] - 'a']; X SOCK_HOSTS[sHostName[0] - 'a'] = pFinger; X } X } X } X X if (pFinger) X *pIpAddr = pFinger->lHost; X } X X return(iErr); X X } /* Sock_StrHost2IP */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_IP2StrHost(lIPAddr, sHostName) X u_long lIPAddr; X char *sHostName; X{ X TVeosErr iErr; X struct hostent *hostInfo, *gethostbyaddr(); X char *pFinger; X X iErr = VEOS_FAILURE; X X if (sHostName) { X X if (hostInfo = gethostbyaddr((char *) &lIPAddr, sizeof(u_long), AF_INET)) { X strcpy(sHostName, hostInfo->h_name); X X if (pFinger = strchr(sHostName, '.')) X pFinger[0] = '\0'; X X iErr = VEOS_SUCCESS; X } X else X iErr = TALK_HOST; X } X X return(iErr); X X } /* Sock_IP2StrHost */ X/****************************************************************************************/ X X X X X/****************************************************************************************/ XTVeosErr Sock_StrAddr2IP(sHostName, pIpAddr) X char *sHostName; X u_long *pIpAddr; X{ X u_long lResult, lTemp; X char *pCharFinger; X TVeosErr iErr; X X iErr = VEOS_FAILURE; X if (sHostName) { X X lResult = 0; X pCharFinger = sHostName; X X X /* first byte */ X lTemp = (u_long) atoi(pCharFinger); X lResult |= lTemp << 24; X X X /* second byte */ X pCharFinger = strchr(pCharFinger, '.'); X pCharFinger ++; X X lTemp = (u_long) atoi(pCharFinger); X lResult |= lTemp << 16; X X X /* third byte */ X pCharFinger = strchr(pCharFinger, '.'); X pCharFinger ++; X X lTemp = (u_long) atoi(pCharFinger); X lResult |= lTemp << 8; X X X /* fourth byte */ X pCharFinger = strchr(pCharFinger, '.'); X pCharFinger ++; X X lTemp = (u_long) atoi(pCharFinger); X lResult |= lTemp; X X X *pIpAddr = lResult; X X iErr = VEOS_SUCCESS; X } X X return(iErr); X X } /* Sock_StrAddr2IP */ X/****************************************************************************************/ X X X X/****************************************************************************************/ XTVeosErr Sock_IP2StrAddr(lIpAddr, sHostName) X u_long lIpAddr; X char *sHostName; X{ X TVeosErr iErr; X X iErr = VEOS_FAILURE; X if (sHostName) { X X sprintf(sHostName, "%d.%d.%d.%d", X (lIpAddr >> 24) & 0x000000FF, X (lIpAddr >> 16) & 0x000000FF, X (lIpAddr >> 8) & 0x000000FF, X lIpAddr & 0x000000FF); X X iErr = VEOS_SUCCESS; X } X X return(iErr); X X } /* Sock_IP2StrAddr */ X/****************************************************************************************/ X X X X X X END_OF_FILE if test 16709 -ne `wc -c <'kernel_private/src/talk/socket.c'`; then echo shar: \"'kernel_private/src/talk/socket.c'\" unpacked with wrong size! fi # end of 'kernel_private/src/talk/socket.c' fi if test -f 'src/kernel_current/fern/fe_int.lsp' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/kernel_current/fern/fe_int.lsp'\" else echo shar: Extracting \"'src/kernel_current/fern/fe_int.lsp'\" $16110 characters$ sed "s/^X//" >'src/kernel_current/fern/fe_int.lsp' <<'END_OF_FILE' X;;----------------------------------------------------------- X;; file: fe_int.lsp X;; X;; FERN is the Fractal Entity Relativity Node. X;; Part of the FE component of the Fern System. X;; X;; creation: March 28, 1992 X;; X;; by Geoffrey P. Coco at the HITLab, Seattle X;;----------------------------------------------------------- X X X;;----------------------------------------------------------- X;; Copyright (C) 1992 Geoffrey P. Coco, X;; Human Interface Technology Lab, Seattle X;;----------------------------------------------------------- X X X;;=========================================================== X;; Internal X;;=========================================================== X X(defun fe-put.int (int) X (vput int '((~ "perc" X @ X @ X > @) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int (&key (test-time nil)) X (car (vcopy '(("perc" X @ X @ X > @) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int () X (vget '(("perc" X @ X @ X (> @@) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int () X (car (vput "%" '((~ "perc" X @ X @ X > @) **)))) X X;;----------------------------------------------------------- X X X X X;;----------------------------------------------------------- X;; The following functions which manipulate the locl X;; sub-partition were composed by Andy MacDonald X;;----------------------------------------------------------- X X X;;=========================================================== X;; Local X;;=========================================================== X X(defun fe-put.int.locl (locl) X (vput locl '((~ "perc" X @2 X (> @ @2)) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int.locl (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (> @ @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.locl () X (vget '(("perc" X @2 X ((> @@) @2)) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl () X (car (vput '((~ "perc" X @2 X (> @ @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Objects X;;=========================================================== X X(defun fe-jam.int.locl.ob (ob) X (vput ob '((~ "perc" X @2 X ((^ @@) @2)) **))) X X;;----------------------------------------------------------- X X;; objects are (ob-name (attr-list)) X(defun fe-put.int.locl.ob (ob) X (cond X X ;; assume object is already there X ((car (vput ob `((~ "perc" X @2 X ((> (,(car ob) @) **) @2)) **)))) X X ;; object wasn't there, insert new one X ((fe-jam.int.locl.ob ob)) X )) X X;;----------------------------------------------------------- X X;; pass object name X(defun fe-copy.int.locl.ob (ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X ((> (,ob-name @) **) @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass object name, returns entire object X(defun fe-xtrct.int.locl.ob (ob-name) X (car (vget `(("perc" X @2 X ((> (,ob-name @) **) @2)) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl.ob (ob-name) X (car (vput "%" `((~ "perc" X @2 X (((~ ,ob-name > @) **) @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Object - Complex X;;=========================================================== X X(defun fe-copy.int.locl.ob.names () X (vcopy `(("perc" X @2 X (((> @ @) **) @2)) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Local Object Attributes X;;=========================================================== X X(defun fe-jam.int.locl.ob.attr (ob-name attr) X (cond X ;; assume object exists, add new attr X ((vput attr `((~ "perc" X @2 X (((~ ,ob-name (^ @@)) **) @2)) **))) X X ;; object didn't exist, add new object with new attr. X ((fe-jam.int.locl.ob `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X(defun fe-put.int.locl.ob.attr (ob-name attr) X (cond X X ;; assume the object and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @2 X (((~ ,ob-name (> (,(car attr) @) **)) **) @2)) **)))) X X ;; attr didn't exist, add new attr X ((fe-jam.int.locl.ob.attr ob-name attr)) X )) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.locl.ob.attr (ob-name attr-name) X (car (vget `(("perc" X @2 X (((,ob-name (> (,attr-name @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.locl.ob.attr (ob-name attr-name) X (car (vput "%" `((~ "perc" X @2 X (((~ ,ob-name ((~ ,attr-name > @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X;; returns attr struct X(defun fe-copy.int.locl.ob.attr (ob-name attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (((,ob-name (> (,attr-name @) **)) **) @2)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Local Object Attributes - Complex X;;=========================================================== X X;; returns list of boundary attribute names X(defun fe-copy.int.locl.ob.attr.names (ob-name) X (vcopy `(("perc" X @2 X (((,ob-name ((> @ @) **)) **) @2)) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; returns attr val X(defun fe-copy.int.locl.ob.attr.val (ob-name attr-name) X (car (vcopy `(("perc" X @2 X (((,ob-name ((,attr-name > @) **)) **) @2)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sublings X;;=========================================================== X X(defun fe-put.int.subs (subs) X (vput subs '((~ "perc" X @2 X (@ > @ @)) **))) X X;;----------------------------------------------------------- X X;; cache this frequently used pattern in C level fern. X;; later, calls to fe-copy.int.subs use precomputed pattern. X X(fbase-init-copy.int.subs '(("perc" X @2 X (@ > @ @)) **)) X X#| X(defun fe-copy.int.subs (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (@ > @ @)) **) X :test-time test-time))) X|# X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs () X (vget '(("perc" X @2 X (@ (> @@) @)) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs () X (car (vput "%" '((~ "perc" X @2 X (@ > @ @)) **)))) X X;;----------------------------------------------------------- X X X;;=========================================================== X;; Sublings Entities X;;=========================================================== X X(defun fe-jam.int.subs.ent (ent) X (vput ent '((~ "perc" X @2 X (@ (^ @@) @)) **))) X X;;----------------------------------------------------------- X X;; an ent is: (uid (ob-list)) X(defun fe-put.int.subs.ent (ent) X (cond X X ;; assume the ent exists, swap in the new ent X ((car (vput ent `((~ "perc" X @2 X (@ (> (,(car ent) @) **) @) X ) **)))) X X ;; ent didn't exist, insert new ent X ((fe-jam.int.subs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.subs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ (> (,uid @) **) @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs.ent (uid) X (car (vget `(("perc" X @2 X (@ (> (,uid @) **) @) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs.ent (uid) X (car (vput "%" `((~ "perc" X @2 X (@ ((~ ,uid > @) **) @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Sublings Entities - Complex X;;=========================================================== X X(defun fe-copy.int.subs.uids () X (vcopy '(("perc" X @2 X (@ ((> @ @) **) @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Sublings Entities Objects X;;=========================================================== X X X(defun fe-jam.int.subs.ent.ob (uid ob) X (cond X X ;; assume entity exists, insert new object X ((vput ob `((~ "perc" X @2 X (@ ((~ ,uid (^ @@)) **) @) X ) **))) X X ;; entity wasn't there, insert new entity with new object X ((fe-jam.int.subs.ent `(,uid (,ob)))) X )) X X;;----------------------------------------------------------- X X;; ob is a normal object structure: (name (attr-list)) X(defun fe-put.int.subs.ent.ob (uid ob) X (cond X X ;; assume entity and object exist, swap in new object X ((car (vput ob `((~ "perc" X @2 X (@ ((~ ,uid (> (,(car ob) @) **)) **) @) X ) **)))) X X ;; object wasn't there, assume entity exists, insert new object X ((fe-jam.int.subs.ent.ob uid ob)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.subs.ent.ob (uid ob-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ ((,uid (> (,ob-name @) **)) **) @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.subs.ent.ob (uid ob-name) X (car (vget `(("perc" X @2 X (@ ((,uid (> (,ob-name @) **)) **) @) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.subs.ent.ob (uid ob-name) X (car (vput "%" `((~ "perc" X @2 X (@ ((~ ,uid ((~ ,ob-name > @) **)) **) @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Subling Entities Objects - Complex X;;=========================================================== X X;; pass uid, get list of it's ob names X(defun fe-copy.int.subs.ent.ob.names (uid) X (vcopy `(("perc" X @2 X (@ ((,uid ((> @ @) **)) **) @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Subling Entities Objects Attributes X;;=========================================================== X X X(defun fe-jam.int.subs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume entity and ob exists, insert new attr X ((vput attr `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-name (^ @@)) **)) **) X @) X ) **))) X X ;; ob wasn't there, insert new ob with new attr X ((fe-jam.int.subs.ent.ob uid `(,ob-name (,attr)))) X )) X X;;----------------------------------------------------------- X X;; attr is ("attr-name" attr-val) X(defun fe-put.int.subs.ent.ob.attr (uid ob-name attr) X (cond X ;; assume the ent, ob and attr exist, swap in new attr X ((car (vput attr `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-name (> (,(car attr) @) **)) **)) **) X @) X ) **)))) X X ;; attr wasn't there, insert new attr X ((fe-jam.int.subs.ent.ob.attr uid ob-name attr)) X )) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.int.subs.ent.ob.attr (uid ob-num attr-name &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-xtrct.int.subs.ent.ob.attr (uid ob-num attr-name) X (car (vget `(("perc" X @2 X (@ X ((,uid ((,ob-num (> (,attr-name @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-get.int.subs.ent.ob.attr (uid ob-num attr-name) X (car (vput "%" `((~ "perc" X @2 X (@ X ((~ ,uid ((~ ,ob-num ((~ ,attr-name > @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Subling Entities Objects Attributes - Complex X;;=========================================================== X X;; pass uid and ob, return attr-list X(defun fe-copy.int.subs.ent.ob.attr.names (uid ob-name) X (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-name ((> @ @) **)) **)) **) X @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass attr, return values of all objects of all sibs X(defun fe-copy.int.subs.attr.vals (attr-name) X (vcopy `(("perc" X @2 X (@ X ((@ ((@ ((,attr-name > @) **)) **)) **) X @) X ) **) X :freq "all")) X X;;----------------------------------------------------------- X X;; pass uid, ob-num, attr-name X(defun fe-copy.int.subs.ent.ob.attr.val (uid ob-num attr-name) X (car (vcopy `(("perc" X @2 X (@ X ((,uid ((,ob-num ((,attr-name > @) **)) **)) **) X @) X ) **)))) X X;;----------------------------------------------------------- X X X X X X;;=========================================================== X;; Filters X;;=========================================================== X X(defun fe-put.int.fltrs (fltr) X (vput fltr '((~ "perc" X @2 X (@2 > @)) **))) X X;;----------------------------------------------------------- X X(defun fe-copy.int.fltrs (&key (test-time nil)) X (car (vcopy '(("perc" X @2 X (@2 > @)) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.fltrs () X (vget '(("perc" X @2 X (@2 (> @@))) **))) X X;;----------------------------------------------------------- X X(defun fe-get.int.fltrs () X (car (vput "%" '((~ "perc" X @2 X (@2 > @)) **)))) X X;;----------------------------------------------------------- X X X X;;=========================================================== X;; Fltrs Entities X;;=========================================================== X X(defun fe-jam.int.fltrs.ent (ent) X (vput ent '((~ "perc" X @2 X (@2 (^ @@))) **))) X X;;----------------------------------------------------------- X X;; an ent is: (uid (ob-list)) X(defun fe-put.int.fltrs.ent (ent) X (cond X X ;; assume the ent exists, swap in the new ent X ((car (vput ent `((~ "perc" X @2 X (@2 (> (,(car ent) @) **)) X ) **)))) X X ;; ent didn't exist, insert new ent X ((fe-jam.int.fltrs.ent ent)) X )) X X;;----------------------------------------------------------- X X(defun fe-copy.int.fltrs.ent (uid &key (test-time nil)) X (car (vcopy `(("perc" X @2 X (@2 (> (,uid @) **)) X ) **) X :test-time test-time))) X X;;----------------------------------------------------------- X X(defun fe-xtrct.int.fltrs.ent (uid) X (car (vget `(("perc" X @2 X (@2 (> (,uid @) **)) X ) **)))) X X;;----------------------------------------------------------- X X(defun fe-get.int.fltrs.ent (uid) X (car (vput "%" `((~ "perc" X @2 X (@2 ((~ ,uid > @) **)) X ) **)))) X X;;----------------------------------------------------------- X X X X X;;=========================================================== X;; Internal Entity Filter Processing X;;=========================================================== X X X;;----------------------------------------------------------- X X(defun fe-fltr.int.subs (uid &key (test-time nil)) X (delete uid X (fe-copy.int.subs :test-time test-time) X :test (lambda (x y) (equal x (car y))))) X X;;----------------------------------------------------------- X X(defun fe-fltr.int.subs.uids (uid) X (delete uid X (fe-copy.int.subs.uids) X :test 'equal)) X X;;----------------------------------------------------------- X X X X END_OF_FILE if test 16110 -ne `wc -c <'src/kernel_current/fern/fe_int.lsp'`; then echo shar: \"'src/kernel_current/fern/fe_int.lsp'\" unpacked with wrong size! fi # end of 'src/kernel_current/fern/fe_int.lsp' fi if test -f 'src/xlisp/xcore/c/xlobj.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlobj.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlobj.c'\" $16437 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlobj.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlobj.c X* RCS: $Header: xlobj.c,v 1.3 89/11/25 05:41:26 mayer Exp $ X* Description: xlisp object functions X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:41:13 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlobj.c,v 1.3 89/11/25 05:41:26 mayer Exp $"; X X X#include "xlisp.h" X X/* external variables */ Xextern LVAL xlenv,xlfenv,xlvalue; Xextern LVAL s_stdout,s_stderr,s_lambda; Xextern LVAL s_send;/*91Jun15jsp*/ X X/* local variables *//* 90Nov28 jsp exported READ ONLY! */ XLVAL s_self,k_new,k_isnew;/*JSP*/ XLVAL cls_class,cls_object;/*JSP*/ X X/* forward declarations */ XFORWARD LVAL entermsg(); XFORWARD LVAL x_sendmsg(); XFORWARD LVAL evmethod(); X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLOBJ_C_GLOBALS X#include "../../xmodules.h" X#undef MODULE_XLOBJ_C_GLOBALS X X/* xsend - send a message to an object */ XLVAL xsend() X{ X LVAL obj; X obj = xlgaobject(); X return (x_sendmsg(obj,getclass(obj),xlgasymbol())); X} X X/* xsendsuper - send a message to the superclass of an object */ XLVAL xsendsuper() X{ X LVAL env,p; X for (env = xlenv; env; env = cdr(env)) X if ((p = car(env)) && objectp(car(p))) X return (x_sendmsg(car(p), X getivar(cdr(p),SUPERCLASS), X xlgasymbol())); X xlfail("not in a method"); X} X X/* xlclass - define a class */ XLVAL xlclass(name,vcnt) X char *name; int vcnt; X{ X LVAL sym,cls; X X /* create the class */ X sym = xlenter(name); X cls = newobject(cls_class,CLASSSIZE); X setvalue(sym,cls); X X /* set the instance variable counts */ X setivar(cls,IVARCNT,cvfixnum((FIXTYPE)vcnt)); X setivar(cls,IVARTOTAL,cvfixnum((FIXTYPE)vcnt)); X X /* set the superclass to 'Object' */ X setivar(cls,SUPERCLASS,cls_object); X X /* return the new class */ X return (cls); X} X X#ifdef PROVIDE_WINTERP X/* xlclass_p -- check if object is a class object as created by xlclass() */ Xint xlclass_p(o_class) X LVAL o_class; /* assume type==OBJECT */ X{ X return (getclass(o_class) == cls_class); X} X#endif X X/* xladdivar - enter an instance variable */ Xxladdivar(cls,var) X LVAL cls; char *var; X{ X setivar(cls,IVARS,cons(xlenter(var),getivar(cls,IVARS))); X} X X/* xladdmsg - add a message to a class */ Xxladdmsg(cls,msg,offset) X LVAL cls; char *msg; int offset; X{ X extern FUNDEF *funtab; X LVAL mptr; X X /* enter the message selector */ X mptr = entermsg(cls,xlenter(msg)); X X /* store the method for this message */ X rplacd(mptr,cvsubr(funtab[offset].fd_subr,funtab[offset].fd_type,offset)); X} X X/* xlobgetvalue - get the value of an instance variable */ Xint xlobgetvalue(pair,sym,pval) X LVAL pair; /* pair is from an xlenv environment frame. */ X /* car(pair) is an object. */ X /* cdr(pair) a [maybe super-]class of object. */ X LVAL sym; /* Symbol whose value we're trying to locate. */ X LVAL *pval; /* Return path for value. */ X{ /* Return TRUE if we find sym, else FALSE. */ X LVAL cls,names; X int ivtotal,n; X X /* find the instance or class variable */ X for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { X X /* check the instance variables */ X names = getivar(cls,IVARS); X ivtotal = getivcnt(cls,IVARTOTAL); X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) { X if (car(names) == sym) { X *pval = getivar(car(pair),n); X return (TRUE); X } X names = cdr(names); X } X X /* check the class variables */ X names = getivar(cls,CVARS); X for (n = 0; consp(names); ++n) { X if (car(names) == sym) { X *pval = getelement(getivar(cls,CVALS),n); X return (TRUE); X } X names = cdr(names); X } X } X X /* variable not found */ X return (FALSE); X} X X/* xlobsetvalue - set the value of an instance variable */ Xint xlobsetvalue(pair,sym,val) X LVAL pair,sym,val; X{ X LVAL cls,names; X int ivtotal,n; X X /* find the instance or class variable */ X for (cls = cdr(pair); objectp(cls); cls = getivar(cls,SUPERCLASS)) { X X /* check the instance variables */ X names = getivar(cls,IVARS); X ivtotal = getivcnt(cls,IVARTOTAL); X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) { X if (car(names) == sym) { X setivar(car(pair),n,val); X return (TRUE); X } X names = cdr(names); X } X X /* check the class variables */ X names = getivar(cls,CVARS); X for (n = 0; consp(names); ++n) { X if (car(names) == sym) { X setelement(getivar(cls,CVALS),n,val); X return (TRUE); X } X names = cdr(names); X } X } X X /* variable not found */ X return (FALSE); X} X X/* obisnew - default 'isnew' method */ XLVAL obisnew() X{ X LVAL self; X self = xlgaobject(); X xllastarg(); X return (self); X} X X/* obclass - get the class of an object */ XLVAL obclass() X{ X LVAL self; X self = xlgaobject(); X xllastarg(); X return (getclass(self)); X} X X/* obshow - show the instance variables of an object */ XLVAL obshow() X{ X LVAL self,fptr,cls,names; X int ivtotal,n; X X /* get self and the file pointer */ X self = xlgaobject(); X fptr = (moreargs() ? xlgetfile() : getvalue(s_stdout)); X xllastarg(); X X /* get the object's class */ X cls = getclass(self); X X /* print the object and class */ X xlputstr(fptr,"Object is "); X xlprint(fptr,self,TRUE); X xlputstr(fptr,", Class is "); X xlprint(fptr,cls,TRUE); X xlterpri(fptr); X X /* print the object's instance variables */ X for (; cls; cls = getivar(cls,SUPERCLASS)) { X names = getivar(cls,IVARS); X ivtotal = getivcnt(cls,IVARTOTAL); X for (n = ivtotal - getivcnt(cls,IVARCNT); n < ivtotal; ++n) { X X xlputstr(fptr," "); X xlprint(fptr,car(names),TRUE); X xlputstr(fptr," = "); X xlprint(fptr,getivar(self,n),TRUE); X xlterpri(fptr); X names = cdr(names); X } X } X X /* return the object */ X return (self); X} X X X/* clnew - create a new object instance */ XLVAL clnew() X{ X LVAL self; X self = xlgaobject(); X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLOBJ_C_CLNEW X#include "../../xmodules.h" X#undef MODULE_XLOBJ_C_CLNEW X X return (newobject( self,getivcnt(self,IVARTOTAL))); X} X X/* clisnew - initialize a new class */ XLVAL clisnew() X{ X LVAL self,ivars,cvars,super; X int n; X X /* get self, the ivars, cvars and superclass */ X self = xlgaobject(); X ivars = xlgalist(); X cvars = (moreargs() ? xlgalist() : NIL); X super = (moreargs() ? xlgaobject() : cls_object); X xllastarg(); X X /* store the instance and class variable lists and the superclass */ X setivar(self,IVARS,ivars); X setivar(self,CVARS,cvars); X setivar(self,CVALS,(cvars ? newvector(listlength(cvars)) : NIL)); X setivar(self,SUPERCLASS,super); X X /* compute the instance variable count */ X n = listlength(ivars); X setivar(self,IVARCNT,cvfixnum((FIXTYPE)n)); X n += getivcnt(super,IVARTOTAL); X setivar(self,IVARTOTAL,cvfixnum((FIXTYPE)n)); X X /* return the new class object */ X return (self); X} X X/* clanswer - define a method for answering a message */ XLVAL clanswer() X{ X LVAL self,msg,fargs,code,mptr; X X /* message symbol, formal argument list and code */ X self = xlgaobject(); X msg = xlgasymbol(); X fargs = xlgalist(); X code = xlgalist(); X xllastarg(); X X /* make a new message list entry */ X mptr = entermsg(self,msg); X X /* set up the message node */ X xlprot1(fargs); X fargs = cons(s_self,fargs); /* add 'self' as the first argument */ X rplacd(mptr,xlclose(msg,s_lambda,fargs,code,xlenv,xlfenv)); /* changed by NPM -- pass in lexical and functional environment */ X xlpop(); X X /* return the object */ X return (self); X} X X/* entermsg - add a message to a class */ XLOCAL LVAL entermsg(cls,msg) X LVAL cls,msg; X{ X LVAL lptr,mptr; X X /* look up the message */ X for (lptr = getivar(cls,MESSAGES); lptr; lptr = cdr(lptr)) X if (car(mptr = car(lptr)) == msg) X return (mptr); X X /* allocate a new message entry if one wasn't found */ X xlsave1(mptr); X mptr = consa(msg); X setivar(cls,MESSAGES,cons(mptr,getivar(cls,MESSAGES))); X xlpop(); X X /* return the symbol node */ X return (mptr); X} X X/* xsendmsgN - external entry to send a message to an object, N args: */ XLVAL xsendmsgN(obj,sym,args,arg1,arg2,arg3) /*Created 91Jun15jsp*/ XLVAL obj,sym; Xint args; XLVAL arg1,arg2,arg3; X{ X /* This is basically ripped off from the SUBR case of xleval.c:evform(). */ X LVAL val; X LVAL *argv; X int argc; X X xllastarg(); /* Make sure nothing on stack */ X argv = xlargv; X argc = xlargc; X X args+= 2; /* Count obj and sym as args. */ X { /* Begin inlineed simplified pushargs() */ X /* build a new argument stack frame */ X LVAL*newfp = xlsp; X pusharg(cvfixnum((FIXTYPE)(newfp - xlfp))); X pusharg(xlgetfunction(s_send)); X pusharg(cvfixnum((FIXTYPE)args)); /* argc(ount) */ X pusharg( obj ); /* Push message recipient. */ X pusharg( sym ); /* Push message selector. */ X if (args > 2) pusharg( arg1 ); X if (args > 3) pusharg( arg2 ); X if (args > 4) pusharg( arg3 ); X xlfp = newfp; /* Establish the new stack frame. */ X xlargc = args; /* Remember the number of arguments. */ X } /* End inlineed simplified pushargs() */ X X xlargv = xlfp + 3; X val = xsend(); X xlsp = xlfp; X xlfp = xlfp - (int)getfixnum(*xlfp); X xlargv = argv; X xlargc = argc; X return val; X} X/* xsendmsg0 - external entry to send a message to an object, no arg */ XLVAL xsendmsg0(obj,sym) /*Created 91Jun16jsp*/ XLVAL obj,sym; X{ X return xsendmsgN(obj,sym,0,NIL,NIL,NIL); X} X/* xsendmsg1 - external entry to send a message to an object, 1 arg */ XLVAL xsendmsg1(obj,sym,arg1) /*Created 91Jun15jsp*/ XLVAL obj,sym,arg1; X{ X return xsendmsgN(obj,sym,1,arg1,NIL,NIL); X} X/* xsendmsg2 - external entry to send a message to an object, 2 args */ XLVAL xsendmsg2(obj,sym,arg1,arg2) /*Created 91Jun16jsp*/ XLVAL obj,sym,arg1,arg2; X{ X return xsendmsgN(obj,sym,2,arg1,arg2,NIL); X} X/* xsendmsg3 - external entry to send a message to an object, 3 args */ XLVAL xsendmsg3(obj,sym,arg1,arg2,arg3) /*Created 91Jun16jsp*/ XLVAL obj,sym,arg1,arg2,arg3; X{ X return xsendmsgN(obj,sym,3,arg1,arg2,arg3); X} X X/* x_sendmsg - internal entry to send a message to an object */ XLOCAL LVAL x_sendmsg(obj,cls,sym) X LVAL obj,cls,sym; X{ X LVAL msg,msgcls,method,val,p; X X /* look for the message in the class or superclasses */ X for (msgcls = cls; msgcls; ) { X X /* lookup the message in this class */ X for (p = getivar(msgcls,MESSAGES); p; p = cdr(p)) X if ((msg = car(p)) && car(msg) == sym) X goto send_message; X X /* look in class's superclass */ X msgcls = getivar(msgcls,SUPERCLASS); X } X X /* message not found */ X xlerror("no method for this message",sym); X Xsend_message: X X /* insert the value for 'self' (overwrites message selector) */ X *--xlargv = obj; X ++xlargc; X X /* invoke the method */ X if ((method = cdr(msg)) == NULL) X xlerror("bad method",method); X switch (ntype(method)) { X case SUBR: X val = (*getsubr(method))(); X break; X case CLOSURE: X if (gettype(method) != s_lambda) X xlerror("bad method",method); X val = evmethod(obj,msgcls,method); X break; X default: X xlerror("bad method",method); X } X X /* after creating an object, send it the ":isnew" message */ X if (car(msg) == k_new && val) { X xlprot1(val); X x_sendmsg(val,getclass(val),k_isnew); X xlpop(); X } X X /* return the result value */ X return (val); X} X X/* evmethod - evaluate a method */ XLOCAL LVAL evmethod(obj,msgcls,method) X LVAL obj,msgcls,method; X{ X LVAL oldenv,oldfenv,cptr,name,val; X CONTEXT cntxt; X X /* protect some pointers */ X xlstkcheck(3); X xlsave(oldenv); X xlsave(oldfenv); X xlsave(cptr); X X /* create an 'object' stack entry and a new environment frame */ X oldenv = xlenv; X oldfenv = xlfenv; X xlenv = cons(cons(obj,msgcls),xlgetenv(method)); X xlenv = xlframe(xlenv); X xlfenv = getfenv(method); X X /* bind the formal parameters */ X xlabind(method,xlargc,xlargv); X X /* set up the implicit block */ X if (name = getname(method)) X xlbegin(&cntxt,CF_RETURN,name); X X /* execute the block */ X if (name && xlsetjmp(cntxt.c_jmpbuf)) X val = xlvalue; X else X for (cptr = getbody(method); consp(cptr); cptr = cdr(cptr)) X val = xleval(car(cptr)); X X /* finish the block context */ X if (name) X xlend(&cntxt); X X /* restore the environment */ X xlenv = oldenv; X xlfenv = oldfenv; X X /* restore the stack */ X xlpopn(3); X X /* return the result value */ X return (val); X} X X/* getivcnt - get the number of instance variables for a class */ Xint getivcnt(cls,ivar) X LVAL cls; int ivar; X{ X LVAL cnt; X if ((cnt = getivar(cls,ivar)) == NIL || !fixp(cnt)) X xlfail("bad value for instance variable count"); X return ((int)getfixnum(cnt)); X} X X/* listlength - find the length of a list */ XLOCAL int listlength(list) X LVAL list; X{ X int len; X for (len = 0; consp(list); len++) X list = cdr(list); X return (len); X} X X/* obsymbols - initialize symbols */ Xobsymbols() X{ X /* enter the object related symbols */ X s_self = xlenter("SELF"); X k_new = xlenter(":NEW"); X k_isnew = xlenter(":ISNEW"); X X /* get the Object and Class symbol values */ X cls_object = getvalue(xlenter("OBJECT")); X cls_class = getvalue(xlenter("CLASS")); X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLOBJ_C_OBSYMBOLS X#include "../../xmodules.h" X#undef MODULE_XLOBJ_C_OBSYMBOLS X} X X/* xloinit - object function initialization routine */ Xxloinit() X{ X /* create the 'Class' object */ X cls_class = xlclass("CLASS",CLASSSIZE); X setelement(cls_class,0,cls_class); X X /* create the 'Object' object */ X cls_object = xlclass("OBJECT",0); X X /* finish initializing 'class' */ X setivar(cls_class,SUPERCLASS,cls_object); X xladdivar(cls_class,"IVARTOTAL"); /* ivar number 6 */ X xladdivar(cls_class,"IVARCNT"); /* ivar number 5 */ X xladdivar(cls_class,"SUPERCLASS"); /* ivar number 4 */ X xladdivar(cls_class,"CVALS"); /* ivar number 3 */ X xladdivar(cls_class,"CVARS"); /* ivar number 2 */ X xladdivar(cls_class,"IVARS"); /* ivar number 1 */ X xladdivar(cls_class,"MESSAGES"); /* ivar number 0 */ X xladdmsg(cls_class,":NEW",FT_CLNEW); X xladdmsg(cls_class,":ISNEW",FT_CLISNEW); X xladdmsg(cls_class,":ANSWER",FT_CLANSWER); X X /* finish initializing 'object' */ X setivar(cls_object,SUPERCLASS,NIL); X xladdmsg(cls_object,":ISNEW",FT_OBISNEW); X xladdmsg(cls_object,":CLASS",FT_OBCLASS); X xladdmsg(cls_object,":SHOW",FT_OBSHOW); X X/* Include hybrid-class functions: *//* JSP */ X#define MODULE_XLOBJ_C_XLOINIT X#include "../../xmodules.h" X#undef MODULE_XLOBJ_C_XLOINIT X} X END_OF_FILE if test 16437 -ne `wc -c <'src/xlisp/xcore/c/xlobj.c'`; then echo shar: \"'src/xlisp/xcore/c/xlobj.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlobj.c' fi if test -f 'src/xlisp/xcore/c/xlstr.c' -a "${1}" != "-c" ; then echo shar: Will not clobber existing file \"'src/xlisp/xcore/c/xlstr.c'\" else echo shar: Extracting \"'src/xlisp/xcore/c/xlstr.c'\" $15062 characters$ sed "s/^X//" >'src/xlisp/xcore/c/xlstr.c' <<'END_OF_FILE' X/* -*-C-*- X******************************************************************************** X* X* File: xlstr.c X* RCS: $Header: xlstr.c,v 1.2 89/11/25 05:44:25 mayer Exp $ X* Description: xlisp string and character built-in functions X* Author: David Michael Betz X* Created: X* Modified: Sat Nov 25 05:44:13 1989 (Niels Mayer) mayer@hplnpm X* Language: C X* Package: N/A X* Status: X11r4 contrib tape release X* X* WINTERP 1.0 Copyright 1989 Hewlett-Packard Company (by Niels Mayer). X* XLISP version 2.1, Copyright (c) 1989, by David Betz. X* X* Permission to use, copy, modify, distribute, and sell this software and its X* documentation for any purpose is hereby granted without fee, provided that X* the above copyright notice appear in all copies and that both that X* copyright notice and this permission notice appear in supporting X* documentation, and that the name of Hewlett-Packard and David Betz not be X* used in advertising or publicity pertaining to distribution of the software X* without specific, written prior permission. Hewlett-Packard and David Betz X* make no representations about the suitability of this software for any X* purpose. It is provided "as is" without express or implied warranty. X* X* HEWLETT-PACKARD AND DAVID BETZ DISCLAIM ALL WARRANTIES WITH REGARD TO THIS X* SOFTWARE, INCLUDING ALL IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS, X* IN NO EVENT SHALL HEWLETT-PACKARD NOR DAVID BETZ BE LIABLE FOR ANY SPECIAL, X* INDIRECT OR CONSEQUENTIAL DAMAGES OR ANY DAMAGES WHATSOEVER RESULTING FROM X* LOSS OF USE, DATA OR PROFITS, WHETHER IN AN ACTION OF CONTRACT, NEGLIGENCE X* OR OTHER TORTIOUS ACTION, ARISING OUT OF OR IN CONNECTION WITH THE USE OR X* PERFORMANCE OF THIS SOFTWARE. X* X* See ./winterp/COPYRIGHT for information on contacting the authors. X* X* Please send modifications, improvements and bugfixes to mayer@hplabs.hp.com X* Post XLISP-specific questions/information to the newsgroup comp.lang.lisp.x X* X******************************************************************************** X*/ Xstatic char rcs_identity[] = "@(#)$Header: xlstr.c,v 1.2 89/11/25 05:44:25 mayer Exp $"; X X X X#include "xlisp.h" X X/* local definitions */ X#define fix(n) cvfixnum((FIXTYPE)(n)) X#define TLEFT 1 X#define TRIGHT 2 X X/* external variables */ Xextern LVAL k_start,k_end,k_1start,k_1end,k_2start,k_2end; Xextern LVAL true; Xextern char buf[]; X X/* external procedures */ Xextern char *strcat(); X X/* forward declarations */ XFORWARD LVAL strcompare(); XFORWARD LVAL chrcompare(); XFORWARD LVAL changecase(); XFORWARD LVAL trim(); X X/* string comparision functions */ XLVAL xstrlss() { return (strcompare('<',FALSE)); } /* string< */ XLVAL xstrleq() { return (strcompare('L',FALSE)); } /* string<= */ XLVAL xstreql() { return (strcompare('=',FALSE)); } /* string= */ XLVAL xstrneq() { return (strcompare('#',FALSE)); } /* string/= */ XLVAL xstrgeq() { return (strcompare('G',FALSE)); } /* string>= */ XLVAL xstrgtr() { return (strcompare('>',FALSE)); } /* string> */ X X/* string comparison functions (not case sensitive) */ XLVAL xstrilss() { return (strcompare('<',TRUE)); } /* string-lessp */ XLVAL xstrileq() { return (strcompare('L',TRUE)); } /* string-not-greaterp */ XLVAL xstrieql() { return (strcompare('=',TRUE)); } /* string-equal */ XLVAL xstrineq() { return (strcompare('#',TRUE)); } /* string-not-equal */ XLVAL xstrigeq() { return (strcompare('G',TRUE)); } /* string-not-lessp */ XLVAL xstrigtr() { return (strcompare('>',TRUE)); } /* string-greaterp */ X X/* strcompare - compare strings */ XLOCAL LVAL strcompare(fcn,icase) X int fcn,icase; X{ X int start1,end1,start2,end2,ch1,ch2; X unsigned char *p1,*p2; X LVAL str1,str2; X X /* get the strings */ X str1 = xlgastring(); X str2 = xlgastring(); X X /* get the substring specifiers */ X getbounds(str1,k_1start,k_1end,&start1,&end1); X getbounds(str2,k_2start,k_2end,&start2,&end2); X X /* setup the string pointers */ X p1 = &getstring(str1)[start1]; X p2 = &getstring(str2)[start2]; X X /* compare the strings */ X for (; start1 < end1 && start2 < end2; ++start1,++start2) { X ch1 = *p1++; X ch2 = *p2++; X if (icase) { X if (isupper(ch1)) ch1 = tolower(ch1); X if (isupper(ch2)) ch2 = tolower(ch2); X } X if (ch1 != ch2) X switch (fcn) { X case '<': return (ch1 < ch2 ? fix(start1) : NIL); X case 'L': return (ch1 <= ch2 ? fix(start1) : NIL); X case '=': return (NIL); X case '#': return (fix(start1)); X case 'G': return (ch1 >= ch2 ? fix(start1) : NIL); X case '>': return (ch1 > ch2 ? fix(start1) : NIL); X } X } X X /* check the termination condition */ X switch (fcn) { X case '<': return (start1 >= end1 && start2 < end2 ? fix(start1) : NIL); X case 'L': return (start1 >= end1 ? fix(start1) : NIL); X case '=': return (start1 >= end1 && start2 >= end2 ? true : NIL); X case '#': return (start1 >= end1 && start2 >= end2 ? NIL : fix(start1)); X case 'G': return (start2 >= end2 ? fix(start1) : NIL); X case '>': return (start2 >= end2 && start1 < end1 ? fix(start1) : NIL); X } X} X X/* case conversion functions */ XLVAL xupcase() { return (changecase('U',FALSE)); } XLVAL xdowncase() { return (changecase('D',FALSE)); } X X/* destructive case conversion functions */ XLVAL xnupcase() { return (changecase('U',TRUE)); } XLVAL xndowncase() { return (changecase('D',TRUE)); } X X/* changecase - change case */ XLOCAL LVAL changecase(fcn,destructive) X int fcn,destructive; X{ X unsigned char *srcp,*dstp; X int start,end,len,ch,i; X LVAL src,dst; X X /* get the string */ X src = xlgastring(); X X /* get the substring specifiers */ X getbounds(src,k_start,k_end,&start,&end); X len = getslength(src) - 1; X X /* make a destination string */ X dst = (destructive ? src : newstring(len+1)); X X /* setup the string pointers */ X srcp = getstring(src); X dstp = getstring(dst); X X /* copy the source to the destination */ X for (i = 0; i < len; ++i) { X ch = *srcp++; X if (i >= start && i < end) X switch (fcn) { X case 'U': if (islower(ch)) ch = toupper(ch); break; X case 'D': if (isupper(ch)) ch = tolower(ch); break; X } X *dstp++ = ch; X } X *dstp = '\0'; X X /* return the new string */ X return (dst); X} X X/* trim functions */ XLVAL xtrim() { return (trim(TLEFT|TRIGHT)); } XLVAL xlefttrim() { return (trim(TLEFT)); } XLVAL xrighttrim() { return (trim(TRIGHT)); } X X/* trim - trim character from a string */ XLOCAL LVAL trim(fcn) X int fcn; X{ X unsigned char *leftp,*rightp,*dstp; X LVAL bag,src,dst; X X /* get the bag and the string */ X bag = xlgastring(); X src = xlgastring(); X xllastarg(); X X /* setup the string pointers */ X leftp = getstring(src); X rightp = leftp + getslength(src) - 2; X X /* trim leading characters */ X if (fcn & TLEFT) X while (leftp <= rightp && inbag(*leftp,bag)) X ++leftp; X X /* trim character from the right */ X if (fcn & TRIGHT) X while (rightp >= leftp && inbag(*rightp,bag)) X --rightp; X X /* make a destination string and setup the pointer */ X dst = newstring((int)(rightp-leftp+2)); X dstp = getstring(dst); X X /* copy the source to the destination */ X while (leftp <= rightp) X *dstp++ = *leftp++; X *dstp = '\0'; X X /* return the new string */ X return (dst); X} X X/* getbounds - get the start and end bounds of a string */ XLOCAL getbounds(str,skey,ekey,pstart,pend) X LVAL str,skey,ekey; int *pstart,*pend; X{ X LVAL arg; X int len; X X /* get the length of the string */ X len = getslength(str) - 1; X X /* get the starting index */ X if (xlgkfixnum(skey,&arg)) { X *pstart = (int)getfixnum(arg); X if (*pstart < 0 || *pstart > len) X xlerror("string index out of bounds",arg); X } X else X *pstart = 0; X X /* get the ending index */ X if (xlgkfixnum(ekey,&arg)) { X *pend = (int)getfixnum(arg); X if (*pend < 0 || *pend > len) X xlerror("string index out of bounds",arg); X } X else X *pend = len; X X /* make sure the start is less than or equal to the end */ X if (*pstart > *pend) X xlerror("starting index error",cvfixnum((FIXTYPE)*pstart)); X} X X/* inbag - test if a character is in a bag */ XLOCAL int inbag(ch,bag) X int ch; LVAL bag; X{ X unsigned char *p; X for (p = getstring(bag); *p != '\0'; ++p) X if (*p == ch) X return (TRUE); X return (FALSE); X} X X/* xstrcat - concatenate a bunch of strings */ XLVAL xstrcat() X{ X LVAL *saveargv,tmp,val; X unsigned char *str; X int saveargc,len; X X /* save the argument list */ X saveargv = xlargv; X saveargc = xlargc; X X /* find the length of the new string */ X for (len = 0; moreargs(); ) { X tmp = xlgastring(); X len += (int)getslength(tmp) - 1; X } X X /* create the result string */ X val = newstring(len+1); X str = getstring(val); X X /* restore the argument list */ X xlargv = saveargv; X xlargc = saveargc; X X /* combine the strings */ X for (*str = '\0'; moreargs(); ) { X tmp = nextarg(); X strcat(str,getstring(tmp)); X } X X /* return the new string */ X return (val); X} X X/* xsubseq - return a subsequence */ XLVAL xsubseq() X{ X unsigned char *srcp,*dstp; X int start,end,len; X LVAL src,dst; X X /* get string and starting and ending positions */ X src = xlgastring(); X X /* get the starting position */ X dst = xlgafixnum(); start = (int)getfixnum(dst); X if (start < 0 || start > getslength(src) - 1) X xlerror("string index out of bounds",dst); X X /* get the ending position */ X if (moreargs()) { X dst = xlgafixnum(); end = (int)getfixnum(dst); X if (end < 0 || end > getslength(src) - 1) X xlerror("string index out of bounds",dst); X } X else X end = getslength(src) - 1; X xllastarg(); X X /* setup the source pointer */ X srcp = getstring(src) + start; X len = end - start; X X /* make a destination string and setup the pointer */ X dst = newstring(len+1); X dstp = getstring(dst); X X /* copy the source to the destination */ X while (--len >= 0) X *dstp++ = *srcp++; X *dstp = '\0'; X X /* return the substring */ X return (dst); X} X X/* xstring - return a string consisting of a single character */ XLVAL xstring() X{ X LVAL arg; X X /* get the argument */ X arg = xlgetarg(); X xllastarg(); X X /* make sure its not NIL */ X if (null(arg)) X xlbadtype(arg); X X /* check the argument type */ X switch (ntype(arg)) { X case STRING: X return (arg); X case SYMBOL: X return (getpname(arg)); X case CHAR: X buf[0] = (int)getchcode(arg); X buf[1] = '\0'; X return (cvstring(buf)); X default: X xlbadtype(arg); X } X} X X/* xchar - extract a character from a string */ XLVAL xchar() X{ X LVAL str,num; X int n; X X /* get the string and the index */ X str = xlgastring(); X num = xlgafixnum(); X xllastarg(); X X /* range check the index */ X if ((n = (int)getfixnum(num)) < 0 || n >= getslength(str) - 1) X xlerror("index out of range",num); X X /* return the character */ X return (cvchar(getstring(str)[n])); X} X X/* xcharint - convert an integer to a character */ XLVAL xcharint() X{ X LVAL arg; X arg = xlgachar(); X xllastarg(); X return (cvfixnum((FIXTYPE)getchcode(arg))); X} X X/* xintchar - convert a character to an integer */ XLVAL xintchar() X{ X LVAL arg; X arg = xlgafixnum(); X xllastarg(); X return (cvchar((int)getfixnum(arg))); X} X X/* xuppercasep - built-in function 'upper-case-p' */ XLVAL xuppercasep() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (isupper(ch) ? true : NIL); X} X X/* xlowercasep - built-in function 'lower-case-p' */ XLVAL xlowercasep() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (islower(ch) ? true : NIL); X} X X/* xbothcasep - built-in function 'both-case-p' */ XLVAL xbothcasep() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (isupper(ch) || islower(ch) ? true : NIL); X} X X/* xdigitp - built-in function 'digit-char-p' */ XLVAL xdigitp() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (isdigit(ch) ? cvfixnum((FIXTYPE)(ch - '0')) : NIL); X} X X/* xcharcode - built-in function 'char-code' */ XLVAL xcharcode() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (cvfixnum((FIXTYPE)ch)); X} X X/* xcodechar - built-in function 'code-char' */ XLVAL xcodechar() X{ X LVAL arg; X int ch; X arg = xlgafixnum(); ch = getfixnum(arg); X xllastarg(); X return (ch >= 0 && ch <= 127 ? cvchar(ch) : NIL); X} X X/* xchupcase - built-in function 'char-upcase' */ XLVAL xchupcase() X{ X LVAL arg; X int ch; X arg = xlgachar(); ch = getchcode(arg); X xllastarg(); X return (islower(ch) ? cvchar(toupper(ch)) : arg); X} X X/* xchdowncase - built-in function 'char-downcase' */ XLVAL xchdowncase() X{ X LVAL arg; X int ch; X arg = xlgachar(); ch = getchcode(arg); X xllastarg(); X return (isupper(ch) ? cvchar(tolower(ch)) : arg); X} X X/* xdigitchar - built-in function 'digit-char' */ XLVAL xdigitchar() X{ X LVAL arg; X int n; X arg = xlgafixnum(); n = getfixnum(arg); X xllastarg(); X return (n >= 0 && n <= 9 ? cvchar(n + '0') : NIL); X} X X/* xalphanumericp - built-in function 'alphanumericp' */ XLVAL xalphanumericp() X{ X int ch; X ch = getchcode(xlgachar()); X xllastarg(); X return (isupper(ch) || islower(ch) || isdigit(ch) ? true : NIL); X} X X/* character comparision functions */ XLVAL xchrlss() { return (chrcompare('<',FALSE)); } /* char< */ XLVAL xchrleq() { return (chrcompare('L',FALSE)); } /* char<= */ XLVAL xchreql() { return (chrcompare('=',FALSE)); } /* char= */ XLVAL xchrneq() { return (chrcompare('#',FALSE)); } /* char/= */ XLVAL xchrgeq() { return (chrcompare('G',FALSE)); } /* char>= */ XLVAL xchrgtr() { return (chrcompare('>',FALSE)); } /* char> */ X X/* character comparision functions (case insensitive) */ XLVAL xchrilss() { return (chrcompare('<',TRUE)); } /* char-lessp */ XLVAL xchrileq() { return (chrcompare('L',TRUE)); } /* char-not-greaterp */ XLVAL xchrieql() { return (chrcompare('=',TRUE)); } /* char-equalp */ XLVAL xchrineq() { return (chrcompare('#',TRUE)); } /* char-not-equalp */ XLVAL xchrigeq() { return (chrcompare('G',TRUE)); } /* char-not-lessp */ XLVAL xchrigtr() { return (chrcompare('>',TRUE)); } /* char-greaterp */ X X/* chrcompare - compare characters */ XLOCAL LVAL chrcompare(fcn,icase) X int fcn,icase; X{ X int ch1,ch2,icmp; X LVAL arg; X X /* get the characters */ X arg = xlgachar(); ch1 = getchcode(arg); X X /* convert to lowercase if case insensitive */ X if (icase && isupper(ch1)) X ch1 = tolower(ch1); X X /* handle each remaining argument */ X for (icmp = TRUE; icmp && moreargs(); ch1 = ch2) { X X /* get the next argument */ X arg = xlgachar(); ch2 = getchcode(arg); X X /* convert to lowercase if case insensitive */ X if (icase && isupper(ch2)) X ch2 = tolower(ch2); X X /* compare the characters */ X switch (fcn) { X case '<': icmp = (ch1 < ch2); break; X case 'L': icmp = (ch1 <= ch2); break; X case '=': icmp = (ch1 == ch2); break; X case '#': icmp = (ch1 != ch2); break; X case 'G': icmp = (ch1 >= ch2); break; X case '>': icmp = (ch1 > ch2); break; X } X } X X /* return the result */ X return (icmp ? true : NIL); X} X END_OF_FILE if test 15062 -ne `wc -c <'src/xlisp/xcore/c/xlstr.c'`; then echo shar: \"'src/xlisp/xcore/c/xlstr.c'\" unpacked with wrong size! fi # end of 'src/xlisp/xcore/c/xlstr.c' fi echo shar: End of archive 7 $of 16$. cp /dev/null ark7isdone MISSING="" for I in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 ; do if test ! -f ark${I}isdone ; then MISSING="${MISSING} ${I}" fi done if test "${MISSING}" = "" ; then echo You have unpacked all 16 archives. rm -f ark[1-9]isdone ark[1-9][0-9]isdone else echo You still need to unpack the following archives: echo " " ${MISSING} fi ## End of shell archive. exit 0